perm filename JUST.F4[NEW,LCS]1 blob
sn#147677 filedate 1975-02-25 generic text, type T, neo UTF8
00100 C TO JUSTIFY SEVERAL MSS FILES AT ONCE. (UP TO 15.)(8*15=120)
00110 C TO CONVERT(ONE FILE AT A TIME)TO NEW FORMAT, USE 'CONVT' AS 'LAST NAME'.
00200 COMMON/RQ/ RN(20000)/Q/PWDS(2500) ,RSTFAC(120),STFF(120),
00400 1 V(200),JR(120),P1,P2,I,M
00450 C M=NUM OF STAVES. (BY 8S)
00500 COMMON JY,L,R8,R4,RDIS /RS/JW(120)
00550
00700 TYPE 1
00800 1 FORMAT(' FILE NAME 1? '$)
00900 ACCEPT 200,N1
01000 200 FORMAT(A5)
01100 TYPE 300
01200 300 FORMAT(' LAST NAME? '$)
01300 ACCEPT 200,N2
01310 TYPE 3011
01320 3011 FORMAT(' TYPE OUTPUT NAME 1 -- '$)
01330 ACCEPT 200,NMX
01340 IF(N2.EQ.'CONVT')GO TO 111
01400 TYPE 100
01500 100 FORMAT(' POS.1, POS.2 - '$)
01600 ACCEPT 111,P1,P2
01700 111 FORMAT(2F)
01800 IF(NMX.EQ.' ')NMX='AAAAA'
01900
01910 JW(1)=1
01920 JR(1)=1
02000 M=1
02100 L=0
02200 JX=1
02300 IX=1
02400 NX=1
02500 NM=N1
02600 40 CALL IFILE(1,NM)
02700 READ (1)J,I,
02800 1 (PWDS(K),K=JX,JX+J),(RN(K),K=IX,I+IX-2),ISCR,(V(K),K=1,ISCR),
02900 1 ISCR,(V(K),K=1,ISCR),(RSTFAC(K),K=NX,NX+7),(STFF(K),K=
03000 1 NX,NX+7),K
03100
03200 IF(N2.EQ.'CONVT')GO TO 2
03210 C ********* TYPE 999 AS POS1. FOR 'CONVERT', NAME2 WILL BE OUTPUT NM.
03300 RX=NX-1
03500
03560 IF(RX.EQ.0)GO TO 410
03600 DO 41 K=JX,JX+J
03700 PWDS(K)=PWDS(K)+L
03800 KX=PWDS(K)+2
03820 C +2 IS FOR STAFF #
03840 41 RN(KX)=RN(KX)+RX
03900 410 IX=I+IX-1
03910 L=IX-1
04000 JX=J+JX
04010 JW(M+1)=JX
04020 C POINTER TO START OF PWDS FOR EACH FILE
04030 JR(M+1)=IX
04100 NX=NX+8
04200 IF(IX.LT.19500)GO TO 400
04300 RRT=IX
04400 TYPE 111,RRT
04500 400 IF(NM.EQ.N2)GO TO 5
04600 NM=NM+2
04700 M=M+1
04800 GO TO 40
04900
05700 2 JJ=1
05800 3001 L=PWDS(JJ)
05900 K=L+1
06000 A=RN(K)
06010 Z=RN(L)
06100 IF(A.LT.5)GO TO 3002
06200 IF(A.LE.10)GO TO 1177
06250 IF(A.NE.20)GO TO 3002
06300 1177 IF(A.NE.6)GO TO 3003
06400 RN(K)=9
06500 GO TO 3002
06600 3003 IF(A.NE.5)GO TO 3004
06700 RN(K)=10
06800 IF(Z.LT.4)GO TO 3010
07000 CALL EXCH(RN(L+5),RN(L+6))
07200 GO TO 3002
07300 3004 IF(A.NE.7)GO TO 3005
07400 RN(K)=17
07500 GO TO 3010
07600 3005 IF(A.EQ.8)RN(K)=5
07700 IF(A.EQ.9)RN(K)=6
07800 IF(A.NE.10)GO TO 3006
07900 RN(K)=8
07910 IF(Z.LT.4)GO TO 3010
07920 CALL EXCH(RN(L+4),RN(L+5))
07930 CALL EXCH(RN(L+6),RN(L+5))
08000 GO TO 3002
08100 3006 IF(A.EQ.20)RN(K)=7
08200 IF(A.NE.18)GO TO 3002
08300 3010 FORMAT(' ITEM ',I3,', CODE ',F3.0)
08400 TYPE 3010,JJ,A
08410 3002 A=RN(L+2)
08420 RN(L+2)=RN(L+3)
08430 RN(L+3)=A
08500 A=L+Z+3
08600 JJ=JJ+1
08700 IF(A.EQ.PWDS(JJ))GO TO 3001
10000 MX=1
10100 CC IF(N2.NE.' ')NM=N2
10200 GO TO 6
10300
10400 5 I=JX-1
10500 C TOTAL IN RN ('I' IN MXX.F4)
10600 CALL JJUST
10700
10800 C START OF WRITER
10810 6 NM=NMX
10900 JX=1
11000 IX=1
11100 NX=1
11300 L=0
11400
11600 MX=M
11700 M=1
11800 7 CALL OFILE(21,NM)
11900 IF(N2.EQ.'CONVT')GO TO 3
12000 J=JW(M+1)-JW(M)
12100 I=JR(M+1)-JR(M)+1
12200 P1=PWDS(JX+J)
12300 RX=NX-1
12350 IF(RX.EQ.0)GO TO 3
12400 DO 61 K=JX,JX+J-1
12500 KX=PWDS(K)
12600 PWDS(K)=KX-L
12700 KX=KX+2
12800 61 RN(KX)=RN(KX)-RX
12850 PWDS(JX+J)=PWDS(JX+J)-L
12900 3 L=I+IX-2
13000 WRITE(21)J,I,
13100 1 (PWDS(K),K=JX,JX+J),(RN(K),K=IX,L),ISCR,(V(K),K=1,ISCR),
13200 1 ISCR,(V(K),K=1,ISCR),(RSTFAC(K),K=NX,NX+7),(STFF(K),K=
13300 1 NX,NX+7),K,K
13400 PWDS(JX+J)=P1
13500 TYPE 60,NM
13600
13700 IF(M.EQ.MX)CALL EXIT
13800 M=M+1
13900 JX=JW(M)
14000 IX=JR(M)
14100
14200 NX=NX+8
14300 END FILE 21
14400 NM=NM+2
14500 GO TO 7
14600 60 FORMAT(1XA5)
14700 END
14800
14900 SUBROUTINE JJUST
15000 DATA RSP/.5/,RI/4.5/,RPX/.2/
15100 COMMON JY,L,R8,R4,RDIS
15200 COMMON/RQ/ RN(20000)/Q/PWDS(2500)
15300 1,RSTFAC(120),STFF(120),R(2,100),JR(120),P1,P2,I,M
15400
15500 DIMENSION IR(2,100)
15600 EQUIVALENCE (R,IR)
15800 IX=PWDS(I+1)-1
15900 PRCNT=1.
16100 RRT=P2
16200 RZRO=P1
16300 R4=P1
16400 IF(RRT.EQ.0)RRT=200
16500 IF(RZRO.EQ.0)RZRO=.001
16600 JCNT=0
16700 RJSZ=RI
16800 CC R6=0
16900 ML=1
17000 ROV=RRT
17100 19 IF(JCNT.GT.9)GO TO 101
17110 RP=PRCNT
17200 RJSZ=RJSZ-RPX
17300 JCNT=JCNT+1
17400 C TEMPORARY COUNTER
17500 TYPE 111,JCNT
17600 111 FORMAT(I4)
17700
17800 DO 11 KN=-3,M*8-4
17900 RSPC=0
18000 CC MQ=MOD(KN,8)
18100 CC IF(MQ.EQ.0)MQ=8
18200 CC MQ=MQ-4
18300 CC R8=MQ
18400 R8=KN
18500 N=0
18600
18700 DO 2 K=1,I
18800 L=PWDS(K)
18900 RA=RN(L+1)
19000 RB=RN(L+3)
19200 IF(RB.LT.RZRO)GO TO 2
19210 IF(RN(L+2).EQ.R8)GO TO 77
19220 IF(RA.NE.4)GO TO 2
19230 C SKIPS HOMED NOTES (IN CHORDS)
19240 77 IF(RA.EQ.1)GO TO 10
19250 27 IF(RA.LE.4)GO TO 177
19260 IF(RA.LT.17)GO TO 2
19270 C LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
19280 177 IF(RA.NE.4)GO TO 10
19290 IF(RN(L).GT.2)GO TO 2
19600 C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
19700 10 N=N+1
19800 R(1,N)=RB
19900 IR(2,N)=L
20000 IF(N.EQ.100)GO TO 28
20100 C ONLY TREATS 100 ITEMS AT A TIME.
20200
20300
20400 2 CONTINUE
20500
20600 IF(N.EQ.0)GO TO 11
20700 CC28 KM=JFAC(L)
20800 C SEE FUNCTION JFAC. RSTFAC PNTR.
20900 28 DO 23 K=1,N
21000 23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
21100 C SKIPS IF ONLY BAR LINES ON THIS STAFF
21200 GO TO 11
21300 24 RSTJC=RSTFAC(KN+4)*PRCNT
21400 CALL SORT2(R,N)
21500
21600 C JUMP IF LAST IS A BAR LINE.
21700 K=0
21800 JLDGR=0
21900 JX=0
22000 22 K=K+1
22100 122 L=IR(2,K)
22200 RA=RN(L+1)
22300 RB=0
22400 RX=RN(L+5)
22410 C RX=PARAM 5
22455 RX6=RN(L+6)
22500 RY=1
22600 RW=AMOD(RN(L+4),100.)
22700 IF(RA.GT.1)GO TO 4
22800 RZ=RN(L+7)
22900 IF(LDGR.NE.JLDGR)JLDGR=0
23000 LDGR=0
23100 JY=K
23200 DO 32 JJ=JY+1,N+1
23300 K=JJ
23400 32 IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
23500 C FOUND HOW MANY MEMBERS TO CHORD.
23600 35 RB=0
23700 K=K-1
23800 RQ=0
23900 RD=0
24000 125 IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
24100 DO 37 JJ=JY,K-1
24200 IF(RD.NE.0)GO TO 38
24300 C FINDS ONLY HIGH OR! LOW LED. LINE.
24400 JIR=IR(2,JJ)
24500 RW=AMOD(RN(JIR+4),100.)
24600 IF(RW.GT.11)GO TO 277
24610 IF(RW.GE.2)GO TO 38
24620 277 LDGR=-1
24800 IF(RW.GT.11)LDGR=1
24900 IF(JLDGR.EQ.LDGR)GO TO 36
25000 JLDGR=LDGR
25100 C LDGR IS FOR LEDGER LINES.
25200 GO TO 38
25300 36 RD=1.5
25400 RQ=RD
25500 38 IF(RB.GT.2)GO TO 222
25600 C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
25700 RZZ=RN(JIR+7)
25800 RE=RN(JIR+5)
26210 IF(RB.GE.2)GO TO 477
26220 IF(RZZ.GE.10)GO TO 377
26230 IF(RE.GE.20)GO TO 477
26240 IF(AMOD(RZZ,10.).EQ.0)GO TO 477
26250 377 RB=1.5+EXTEN(RZZ)
26260 C SPACE FOR DOT OR TAIL(IF STEM UP)
26270 477 IF(ABS(RN(JR+6)).EQ.10)RB=RB+2
26300 C FOR CHORD TONES ON RIGHT OF STEM UP.
26400 C LOOKS THROUGH ALL NOTES OF A CHORD.
26500 222 IF(AMOD(RE,10.).EQ.0)GO TO 37
26600 C JUMP IF NO ACCIS.
26700 425 RD=2*RY+EXTEN(RE)
26800 IF(RQ.GT.RD)RD=RQ
26900 RQ=RD
27000 C FUNCT. EXTEN=AMOD(X,1.)*10.
27100 37 CONTINUE
27200 IF(RY.NE.1)RB=RB-.5*RJSZ
27300 C MINI NOTES NEED LESS SPACE
27400 25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJC
27500 GO TO 17
27600 4 IF(RA.NE.3)GO TO 29
27700 RB=3
27800 IF(RX.GT.100)RB=1.5
27900 C CHECK ON SIZE NEEDED FOR CLEFS
28000 29 IF(RA.NE.4)GO TO 26
28100 RB=-RJSZ/2
28200 RD=.9
28300 GO TO 25
28400 26 IF(RA.NE.18)GO TO 30
28500 IF(RX6.GT.9)GO TO 31
28510 IF(RX.GT.9)GO TO 31
28600 C CHECKS FOR 2-DIGIT METERS
28700 RB=-1
28800 RD=1
28900 GO TO 25
29000 31 RB=2
29100 RD=3
29200 GO TO 25
29300 30 IF(RA.NE.17)GO TO 17
29500 RB=2*(ABS(RX)-1)-2
29600 RD=2
29700 GO TO 25
29800 C SPACES FOR CORRECT NUM OF ACCIS.
29900 17 RC=(RB+RJSZ)*RSTJC
30000 C RJSZ=DEFAULT SIZE
30100 JX=JX+1
30200 R(2,JX)=RC
30300 R(1,JX)=R(1,K)
30400 3 IF(K.LT.N)GO TO 22
30500 RA=R(1,1)
30600 RB=R(2,1)
30700
30800 DO 13 KX=2,JX
30900 RE=R(1,KX)
31000 C POS. BEFORE SHIFTING
31100 IF(ABS(RE-RA).GT..5)GO TO 14
31200 IF(R(2,KX).GT.RB)GO TO 16
31300 C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
31400 GO TO 13
31500 CC IF(RZZ.LE.RB)GO TO 13
31600 C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
31700 CC RB=RZZ-RB
31800 14 RD=RA+RB-RE
31900 IF(RD.LE.0)GO TO 16
32000 C THERE'S ENOUGH ROOM
32100 CC RD=RA+RB-RE+RD
32200 R4=RE+RSPC-.001
32300 R5=1000
32400 C MAYBE MORE? ↑↑↑↑↑
32500 R8=RD
32600 R9=0
32700 RSPC=RSPC+RD
32800 C RSPC SAVES TOTAL SPACE ADDED
32900 C GO EXPAND IT
33000 IF(R(2,KX).NE.0)GO TO 66
33100 16 RB=R(2,KX)
33200 13 RA=RE
33300 11 CONTINUE
33400 110 IF(ROV.LE.RRT+.01)GO TO 18
33500 IF(RJSZ.GT.4)RJSZ=4
33600 PRCNT=(ROV-RZRO)/(RRT-RZRO)
34000 IF(PRCNT.NE.RP)GO TO 19
34100 R4=RZRO
34200 R5=ROV
34300 R8=RZRO
34400 R9=RRT-.001
34500 C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
34600 ML=2
34700 GO TO 66
34800 18 ML=3
34900 R8=RRT-ROV
35000 R9=0
35100 C GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
35200 R4=RRT+.001
35300 CC R5=ROV+2
35400 R5=ROV+100
35600 66 JY=1
35900 L=JY
36000 IF(R9.NE.0)RDIS=(R9-R8)/(R5-R4)
36100
36200 6551 RB=RN(JY)
36400 C IF STAFF#>4, ALL STAVES ARE MOVED.
36500 RA=RN(JY+1)
36600 C SKIPS IF NOT SPECIAL CODE NUM.
36700 RN3=RN(JY+3)
36800 IF(RN3.GT.R5)GO TO 7551
36900 RC=-1
37000 RD=0
37710 IF(RA.LT.5)GO TO 677
37716 IF(RA.LE.7)RD=-1
37722 677 IF(RA.EQ.4.)GO TO 777
37728 IF(RD)GO TO 777
37734 IF(RN(JY+5).NE.50)GO TO 877
37740 777 RC=0
37746 C RC=0 FOR CODES 4,5,6
37752 877 RN6=RN(JY+6)
37758 IF(RN3.GE.R4)GO TO 9551
37764 IF(RC)GO TO 7551
37770 IF(RC.NE.0)GO TO 9551
37776 IF(RN6.LE.R4)GO TO 7551
37782 IF(RN6.GE.R5)GO TO 7551
37790 C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
37900 C (50=CRESC., DECRESC.)
37910 9551 IF(RA.EQ.8)GO TO 7552
37955 C 8=STAFF. ONLY MOVES OR COPIES TO NEW STAFF NUM. OTHER PARAMS UNAFFECTED.
38000 RQ6=RN6-R5
38100 RX=0
38200 RV=0
38300 IF(RA.NE.6)GO TO 21
38310 IF(RB.LT.7)GO TO 21
38400 RX=RN(L+9)
38500 RY=RX-R5
38600 RZ=R4-RX
38700 IF(RN(L+10).LT.30)GO TO 221
38800 RW=RN(L+8)
38900 IF(RW.LT.R4)GO TO 221
38910 IF(RW.LE.R5)RV=-1
39000 221 IF(RY.GE.0)GO TO 21
39010 IF(RZ)RX=-1
39100 C PARTIAL BEAM IS WITHIN MOVE AREA.
39200 21 IF(R9.EQ.0)GO TO 2551
39300 IF(RN3.GE.R4)CALL MVBX(3)
39400 IF(RC)GO TO 7552
39600 IF(RA.NE.4.)GO TO 772
39610 IF(RB.LT.4)GO TO 7552
39620 772 IF(RQ6)CALL MVBX(6)
39700 C END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
39800 IF(RA.NE.6)GO TO 7552
39900 IF(RX)CALL MVBX(9)
40000 IF(RV)CALL MVBX(8)
40100 C ONLY TRUE WHEN RA=9
40200 GO TO 7552
40300
40400 2551 IF(RN3.GE.R4)RN3=RN3+R8
40500 RN(L+3)=RN3
40700 IF(RQ6.GE.0)GO TO 773
40710 IF(RD)GO TO 774
40720 IF(RA.NE.4)GO TO 773
40730 IF(RB.LE.3.)GO TO 773
40740 774 RN(L+6)=RN(JY+6)+R8
40750 773 IF(RX)CALL MVBEAM(9)
40800 IF(RV)CALL MVBEAM(8)
40900 IF(RN3.GT.ROV)ROV=RN3
41000 C ??? NOT YET FIXED FOR ENDS OF SLURS OR LINES
41100 7552 L=RB+3+L
41200 7551 JY=RB+3+JY
41300 L=JY
41400 IF(JY.LT.IX)GO TO 6551
41500 GO TO (16,18,101),ML
41600 C ↑↑↑↑↑↑????
41800 101 END
41900
42000 C THESE MOVE ENDS OF PARTIAL INNER BEAMS.
42100 SUBROUTINE MVBEAM(I)
42200 C L AND JY ARE FOR MOVES TO DIFF. STAFF.
42300 COMMON JY,L,R8,R4,RDIS /RQ/RN(20000)
42400 Y=RN(JY+I)
42500 Z=ABS(Y)
42600 IF(Z.LT.100.)GO TO 1
42700 C NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
42800 Y=AMOD(Y,100.)
42900 X=Y+R8
43000 Z=Z-ABS(Y)+ABS(X)
43100 C PUTS ALL INTO POSITIVE
43200 IF(X)Z=-Z
43300 GO TO 2
43400 1 Z=Y+R8
43500 2 RN(L+I)=Z
43600 END
43700
43800 SUBROUTINE MVBX(I)
43900 COMMON JY,L,R8,R4,RDIS /RQ/RN(20000)
44100 RN(L+I)=R8+(RN(JY+I)-R4)*RDIS
44200 END
44300
44400 SUBROUTINE EXCH(X,Y)
44500 Z=X
44600 X=Y
44700 Y=Z
44800 END
44900 SUBROUTINE SORT2(RPOS,M)
45000 DIMENSION RPOS(2,1000)
45100 L=2
45200 3 J=-1
45300 RX=RPOS(1,L-1)
45400 DO 2 K=L,M
45500 IF(RPOS(1,K).GE.RX)GO TO 2
45600 RX=RPOS(1,K)
45700 C WHY WERE ALL THE RX'S JX ????? 9/6/73
45800 J=K
45900 2 CONTINUE
46000 IF(J)GO TO 4
46100 K=L-1
46200 CALL EXCH(RPOS(1,K),RPOS(1,J))
46300 CALL EXCH(RPOS(2,K),RPOS(2,J))
46400 4 L=L+1
46500 IF(L.LE.M)GO TO 3
46600 END
46700
46800 FUNCTION EXTEN(X)
46900 EXTEN=AMOD(X,1.)*10.
47000 END
47100
47200 CC FUNCTION JFAC(L)
47300 C FINDS RSTFAC POINTER
47500 CC COMMON/RQ/ RN(20000)/Q/PWDS(2500)
47600 CC 1,RSTFAC(120),STFF(120),R(2,100),JR(120),P1,P2,I,M
47700 CC K=0
47800 CC1 K=K+1
47900 CC IF(L.GE.JR(K))GO TO 1
48000 CC JFAC=K-2
48100 CC END